home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / pcl-rev4.lha / coral-low.lisp < prev    next >
Lisp/Scheme  |  1990-05-01  |  2KB  |  62 lines
  1. ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. #-:ccl-1.3
  31. (ccl::add-transform 'std-instance-p 
  32.                      :inline 
  33.                      #'(lambda (call)
  34.                          (ccl::verify-arg-count call 1 1)
  35.                          (let ((arg (cadr call)))
  36.                            `(and (eq (ccl::%type-of ,arg) 'structure)
  37.                                  (eq (%svref ,arg 0) 'std-instance)))))
  38.  
  39. (eval-when (eval compile load)
  40.   (proclaim '(inline std-instance-p)))
  41.  
  42. (defun printing-random-thing-internal (thing stream)
  43.   (prin1 (ccl::%ptr-to-int thing) stream))
  44.  
  45. (defun set-function-name-1 (function new-name uninterned-name)
  46.   (declare (ignore uninterned-name))
  47.   (cond ((ccl::lfunp function)
  48.          (ccl::lfun-name function new-name)))
  49.   function)
  50.  
  51.  
  52. (defun doctor-dfun-for-the-debugger (gf dfun)
  53.   #+:ccl-1.3
  54.   (let* ((gfspec (and (symbolp (generic-function-name gf))
  55.               (generic-function-name gf)))
  56.      (arglist (generic-function-pretty-arglist gf)))
  57.     (when gfspec
  58.       (setf (get gfspec 'ccl::%lambda-list)
  59.         (if (and arglist (listp arglist))
  60.         (format nil "~{~A~^ ~}" arglist)
  61.         (format nil "~:A" arglist)))))
  62.   dfun)